VERSION 1.0 CLASS
BEGIN
  MultiUse = -1  'True
  Persistable = 0  'NotPersistable
  DataBindingBehavior = 0  'vbNone
  DataSourceBehavior  = 0  'vbNone
  MTSTransactionMode  = 0  'NotAnMTSObject
END
Attribute VB_Name = "clsAStar"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = True
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = False
Option Explicit
Private Declare Function GetTickCount Lib "kernel32" () As Long

'A* pathfinding algorithm

Private hdg(1 To 40, 1 To 30) As Byte
'0=nothing
'1=hedge
'2=?
Private nd(1 To 40, 1 To 30) As Byte
' 3
'4+1
' 2
'0=nothing
'5=start
'?=?
Private fss() As Byte 'FS
Private fsc As Long

Private hdr As clsListNode 'header of list

Public Property Get PathLength() As Long
PathLength = fsc
End Property

Public Property Get PathFS(ByVal Index As Long) As Byte
PathFS = fss(Index)
End Property

Public Property Get IsHedge(ByVal x As Long, ByVal y As Long) As Byte
IsHedge = hdg(x, y)
End Property

Public Property Let IsHedge(ByVal x As Long, ByVal y As Long, ByVal n As Byte)
hdg(x, y) = n
End Property

Public Function CalcAStar(ByVal xs As Long, ByVal ys As Long, ByVal xe As Long, ByVal ye As Long, Optional ByVal FS As Long) As Boolean
'bug XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX
Dim obj As clsListNode
Dim i As Long
Dim x As Long, y As Long
Dim x1 As Long, y1 As Long
Dim f As Long, st As Long, ex As Single
Dim t As Long
t = GetTickCount
Erase nd
nd(xs, ys) = 5
Set hdr = New clsListNode
With hdr
 .x = xs
 .y = ys
 .Steps = 0
 .Value = CalcValue(xs, ys, xe, ye)
 .FS = FS
End With
Do
 If hdr Is Nothing Then
  'ERROR
  Debug.Assert False
 Else
  x = hdr.x
  y = hdr.y
  f = hdr.FS
  st = hdr.Steps + 1
  ex = hdr.Extra
  If x = xe And y = ye Then 'success?
   fsc = hdr.Steps
   CalcAStar = True
   t = GetTickCount - t
   Debug.Print "Complete in " + CStr(t) + "ms", "Length=" + CStr(fsc), "Extra=" + CStr(hdr.Extra)
   Exit Do
  End If
  'search next node
  For i = 1 To 4
   x1 = x
   y1 = y
   Select Case i
   Case 1: x1 = 1 + x1 Mod 40 'move right
   Case 2: y1 = 1 + y1 Mod 30 'move down
   Case 3: y1 = 1 + (y1 + 28) Mod 30 'move up
   Case 4: x1 = 1 + (x1 + 38) Mod 40 'move left
   End Select
   'If Abs(x - x1) <= 1 And Abs(y - y1) <= 1 Then 'debug:disable xxx
   If hdg(x1, y1) = 0 And nd(x1, y1) = 0 Then 'valid
    Set obj = New clsListNode
    With obj
     .Steps = st
     .x = x1
     .y = y1
     .FS = i
     .Value = CalcValue(x1, y1, xe, ye)
     'If i = f Then .Value = .Value - 0.5
     .Extra = IIf(i <> f, ex + 0.174, ex) 'weight=?
    End With
    InsertNode obj
    nd(x1, y1) = i 'set mark
   End If
   'End If
  Next i
  'no path?
  If hdr.IsLast Then
   Debug.Print "No path!"
   Set hdr = Nothing
   Erase fss
   fsc = 0
   Exit Function
  Else
   Set hdr = hdr.NextNode
  End If
 End If
Loop
'build path
If fsc > 0 Then 'xx ???
 ReDim fss(1 To fsc)
 For i = fsc To 1 Step -1
  fss(i) = nd(x, y)
  Select Case fss(i)
  Case 1: x = 1 + (x + 38) Mod 40 'move right -> left
  Case 2: y = 1 + (y + 28) Mod 30 'move down -> up
  Case 3: y = 1 + y Mod 30 'move up -> down
  Case 4: x = 1 + x Mod 40 'move left ->right
  End Select
 Next i
End If
End Function

Private Function CalcValue(ByVal xs As Long, ByVal ys As Long, ByVal xe As Long, ByVal ye As Long) As Single
xs = Abs(xs - xe)
If xs > 20 Then xs = 40 - xs
ys = Abs(ys - ye)
If ys > 15 Then ys = 30 - ys
CalcValue = Sqr(xs * xs + ys * ys)
'CalcValue = Abs(xs) + Abs(ys) '??
End Function

Private Sub InsertNode(ByVal obj As clsListNode)
Dim obj2 As clsListNode
If obj.GetValueTotal < hdr.GetValueTotal Then 'this is the best node
 Set obj.NextNode = hdr
 Set hdr = obj
 Exit Sub
End If
Set obj2 = hdr
Do
 If obj2.IsLast Then 'the worst node :-X
  obj2.InsertToNext obj
  Exit Do
 ElseIf obj2.NextNode.GetValueTotal >= hdr.GetValueTotal Then
  obj2.InsertToNext obj
  Exit Do
 End If
 Set obj2 = obj2.NextNode
Loop
End Sub

Public Sub Clear()
Erase fss
fsc = 0
End Sub
